Celestin Apprentice 5/Apprentice-Release5.iso/Environments/PowerMacOberon feb96/Source/KeplerGraphs.Mod

Oberon Text | 1995-04-11 | 17KB | 545 lines

Syntax10.Scn.Fnt
MODULE KeplerGraphs;    (* J. Templ, 30.10.90 *)
    IMPORT SYSTEM, KeplerPorts, Display, Files, Oberon, Modules, Types, Texts;
    CONST
        draw* = 0; restore* = 1;    (* notify op-codes *)
        ptSize = 12;
        maxNofpts = 4;
    (* graph = {star} {configuration} 0X.
        star = header contents.
        configuration = header contents.
        header = typeref [typename].
        typeref = compact-integer.
        typename = qualident 0X.
        contents = {byte}. *)
    TYPE
        Object* = POINTER TO ObjectDesc;
        ObjectDesc* = RECORD END ;
        Star* = POINTER TO StarDesc;
        StarDesc* = RECORD
            (ObjectDesc)
            x*, y*, refcnt*, ref: INTEGER;
            sel*: BOOLEAN;
            next* : Star;
        END ;
        Constellation* = POINTER TO ConsDesc;
        ConsDesc* = RECORD
            (ObjectDesc)
            nofpts*: INTEGER;
            p*: ARRAY maxNofpts OF Star;
            next*: Constellation;
        END ;
        Planet* = POINTER TO PlanetDesc;
        PlanetDesc* = RECORD
            (StarDesc)
            c*: Constellation;
        END;
        Graph* = POINTER TO GraphDesc;
        Notifier* = PROCEDURE (op: INTEGER; G: Graph; O: Object; P: KeplerPorts.Port);
        GraphDesc* = RECORD
            (ObjectDesc)
            cons*, lastcons: Constellation;
            stars*, laststar: Star;
            seltime*: LONGINT;
            notify*: Notifier;
        END ;
        StarTab = POINTER TO ARRAY OF LONGINT;
        loading*: Graph;
        update: KeplerPorts.BalloonPort;
        nofpt: INTEGER;
        starTab: StarTab;
        noftypes: LONGINT;
        typTab: ARRAY 256 OF LONGINT;
        del, delG: Graph;
    (* ---------------------------------- abstract methods ---------------------------------- *)
    PROCEDURE (self: Object) Draw* (P: KeplerPorts.Port);
    END Draw;
    PROCEDURE (self: Object) Read* (VAR R: Files.Rider);
    END Read;
    PROCEDURE (self: Object) Write* (VAR R: Files.Rider);
    END Write;
    (* ---------------------------------- auxiliary procedures ---------------------------------- *)
    PROCEDURE err(s0, s1: ARRAY OF CHAR);
        VAR W: Texts.Writer;
    BEGIN Texts.OpenWriter(W);
        Texts.WriteString(W, s0); Texts.WriteString(W, s1); Texts.WriteLn(W);
        Texts.Append(Oberon.Log, W.buf)
    END err;
    PROCEDURE err2(s0, s1: ARRAY OF CHAR);
        VAR W: Texts.Writer;
    BEGIN Texts.OpenWriter(W);
        Texts.WriteString(W, s0); Texts.WriteString(W, s1);
        Texts.Append(Oberon.Log, W.buf)
    END err2;
    PROCEDURE ReadObj* (VAR R: Files.Rider; VAR x: Object);
        VAR ref: LONGINT;
            m: Modules.Module; t: Types.Type;
            module, type: ARRAY 32 OF CHAR;
    BEGIN x := NIL;
        Files.ReadNum(R, ref);
        IF ref = noftypes THEN
            Files.ReadString(R, module);
            Files.ReadString(R, type);
            m := Modules.ThisMod(module);
            IF m # NIL THEN t := Types.This(m, type);
                IF t # NIL THEN typTab[ref] := SYSTEM.VAL(LONGINT, t); INC(noftypes);
                    Types.NewObj(x, t); x.Read(R)
                ELSE err("-- type not found: ", type)
                END
            ELSE err2("-- error: ", Modules.importing);
                IF Modules.res = 2 THEN err(" not an obj-file", "")
                ELSIF Modules.res = 3 THEN err2(" imports ", Modules.imported); err(" with bad key", "");
                ELSIF Modules.res = 4 THEN err(" corrupted obj file", "")
                ELSIF Modules.res = 7 THEN err(" not enough space", "")
                END;
                (*Modules.res := 0*)
            END
        ELSIF ref # -1 THEN
            Types.NewObj(x, SYSTEM.VAL(Types.Type, typTab[ref]));
            x.Read(R)
        END
    END ReadObj;
    PROCEDURE WriteObj* (VAR R: Files.Rider; x: Object);
        VAR typ: Types.Type; i: LONGINT;
    BEGIN
        IF x # NIL THEN
            typ := Types.TypeOf(x); i := 0;
            WHILE (i < noftypes) & (SYSTEM.VAL(LONGINT, typ) # typTab[i]) DO INC(i) END ;
            IF i = noftypes THEN
                Files.WriteNum(R, i);
                typTab[i] := SYSTEM.VAL(LONGINT, typ); INC(noftypes);
                Files.WriteString(R, typ.module.name);
                Files.WriteString(R, typ.name)
            ELSE
                Files.WriteNum(R, i)
            END ;
            x.Write(R)
        ELSE Files.WriteNum(R, -1)
        END
    END WriteObj;
    PROCEDURE GetType* (o: Object; VAR module, type: ARRAY OF CHAR);
        VAR t: Types.Type;
    BEGIN t := Types.TypeOf(o); COPY(t.module.name, module); COPY(t.name, type)
    END GetType;
    PROCEDURE Reset*;
    BEGIN nofpt := 0; noftypes := 0
    END Reset;
    PROCEDURE GetStar (n: INTEGER): Star;
        VAR s: Star;
    BEGIN s := SYSTEM.VAL(Star, starTab[n]); INC(s.refcnt); RETURN s
    END GetStar;
    (* ---------------------------------- Star methods ---------------------------------- *)
    PROCEDURE (self: Star) Draw* (P: KeplerPorts.Port);
    BEGIN
        IF self.sel THEN
            P.FillRect(self.x - ptSize, self.y - ptSize, ptSize*2 + P.scale, ptSize*2 + P.scale, Display.white, 5, Display.invert)
        END
    END Draw;
    PROCEDURE (self: Star) Read* (VAR R: Files.Rider);
        VAR h: LONGINT;
    BEGIN self.sel := FALSE;
        Files.ReadNum(R, h); self.x := SHORT(h);
        Files.ReadNum(R, h); self.y := SHORT(h)
    END Read;
    PROCEDURE (self: Star) Write* (VAR R: Files.Rider);
    BEGIN
        Files.WriteNum(R, self.x);
        Files.WriteNum(R, self.y)
    END Write;
    (* ---------------------------------- Constellation methods ---------------------------------- *)
    PROCEDURE (self: Constellation) State* (): INTEGER;    (* unselected = 0; partially selected = 1; totally selected = 2 *)
        VAR sum, i: INTEGER;
    BEGIN sum := 0; i := 0;
        WHILE i < self.nofpts DO
            IF self.p[i].sel THEN INC(sum) END ;
            INC(i)
        END ;
        IF sum = 0 THEN RETURN 0
        ELSIF sum = self.nofpts THEN RETURN 2
        ELSE RETURN 1
        END
    END State;
    PROCEDURE (self: Constellation) Read* (VAR R: Files.Rider);
        VAR ref, i: LONGINT;
    BEGIN i := 0;
        Files.ReadNum(R, ref); self.nofpts := SHORT(ref);
        i := 0;
        WHILE i < self.nofpts DO
            Files.ReadNum(R, ref);
            self.p[i] := GetStar(SHORT(ref));
            INC(i)
        END
    END Read;
    PROCEDURE (self: Constellation) Write* ( VAR R: Files.Rider);
        VAR i: INTEGER;
    BEGIN i := 0;
        Files.WriteNum(R, self.nofpts);
        WHILE i < self.nofpts DO Files.WriteNum(R, self.p[i].ref); INC(i) END
    END Write;
    (* ---------------------------------- Planet methods ---------------------------------- *)
    PROCEDURE (self: Planet) Draw* (P: KeplerPorts.Port);
    BEGIN
        IF self.sel THEN
            P.DrawRect(self.x - ptSize, self.y - ptSize, ptSize*2, ptSize*2, Display.white, Display.invert)
        END
    END Draw;
    PROCEDURE (self: Planet) Calc*;
    END Calc;
    PROCEDURE (self: Planet) Read* (VAR R: Files.Rider);
        VAR o: Object;
    BEGIN self.Read^(R); ReadObj(R, o); self.c := o(Constellation)
    END Read;
    PROCEDURE (self: Planet) Write* (VAR R: Files.Rider);
    BEGIN self.Write^(R); WriteObj(R, self.c)
    END Write;
    (* ---------------------------------- Graphic methods ---------------------------------- *)
    PROCEDURE (G: Graph) Append*(o: Object);
    BEGIN
        IF o IS Star THEN
            WITH o: Star DO
                IF G.stars = NIL THEN G.stars := o ELSE G.laststar.next := o END ;
                G.laststar := o; o.next := NIL
            END
        ELSE
            WITH o: Constellation DO
                IF G.cons = NIL THEN G.cons := o ELSE G.lastcons.next := o END ;
                G.lastcons := o; o.next := NIL;
                G.notify(draw, G, o, NIL)
            END
        END
    END Append;
    PROCEDURE (G: Graph) FlipSelection*(p: Star);
    BEGIN
        IF p.sel THEN G.notify(draw, G, p, NIL); p.sel := FALSE
        ELSE p.sel := TRUE; G.notify(draw, G, p, NIL); G.seltime := Oberon.Time()
        END
    END FlipSelection;
    PROCEDURE DependsOn(c: Constellation; s: Star): BOOLEAN;
        VAR i: INTEGER; p: Star;
    BEGIN i := 0;
        WHILE i < c.nofpts DO p := c.p[i];
            IF p = s THEN RETURN TRUE
            ELSIF (p IS Planet) & DependsOn(p(Planet).c, s) THEN RETURN TRUE
            END ;
            INC(i)
        END ;
        RETURN FALSE
    END DependsOn;
    PROCEDURE (G: Graph) Move*(s: Star; dx, dy: INTEGER);
        VAR p: Star; c: Constellation;
    BEGIN
        KeplerPorts.InitBalloon(update);
        c := G.cons;
        WHILE c # NIL DO
            IF DependsOn(c, s) THEN c.Draw(update) END ;
            c := c.next
        END ;
        p := s^.next;
        WHILE p # NIL DO
            IF (p IS Planet) & DependsOn(p(Planet).c, s) THEN p.Draw(update) END ;
            p := p.next
        END ;
        s.Draw(update); INC(s.x, dx); INC(s.y, dy); s.Draw(update);
        p := s^.next;
        WHILE p # NIL DO
            IF (p IS Planet) & DependsOn(p(Planet).c, s) THEN p(Planet).Calc; p.Draw(update) END ;
            p := p.next
        END ;
        c := G.cons;
        WHILE c # NIL DO
            IF DependsOn(c, s) THEN c.Draw(update) END ;
            c := c.next
        END ;
        G.notify(restore, G, NIL, update)
    END Move;
    PROCEDURE (G: Graph) MoveSelection*(dx, dy: INTEGER);
        VAR p: Star; c: Constellation;
    BEGIN
        KeplerPorts.InitBalloon(update);
        p := G.stars;
        WHILE p # NIL DO  (*expand selection*)
            IF ~p.sel & (p IS Planet) & (p(Planet).c.State() > 0) THEN p.sel := TRUE END ;
            p := p.next
        END ;
        c := G.cons;
        WHILE c # NIL DO
            IF c.State() # 0 THEN c.Draw(update) END ;
            c := c.next
        END ;
        p := G.stars;
        WHILE p # NIL DO
            IF p.sel THEN
                p.Draw(update);
                IF p IS Planet THEN p(Planet).Calc
                ELSE INC(p.x, dx); INC(p.y, dy)
                END ;
                p.Draw(update)
            END ;
            p := p.next
        END ;
        c := G.cons;
        WHILE c # NIL DO
            IF c.State() # 0 THEN c.Draw(update) END ;
            c := c.next
        END ;
        G.notify(restore, G, NIL, update)
    END MoveSelection;
    PROCEDURE ReverseStars(G: Graph);
        VAR p, first, next: Star;
    BEGIN p := G.stars;
        G.laststar := p; first := NIL;
        WHILE p # NIL DO
            next := p.next; p.next := first;
            first := p; p := next
        END ;
        G.stars := first
    END ReverseStars;
    PROCEDURE Release (self: Constellation);
        VAR i: INTEGER; s: Star;
    BEGIN i := 0;
        WHILE i < self.nofpts DO s := self.p[i]; DEC(s.refcnt); INC(i) END
    END Release;
    PROCEDURE CutCons (G: Graph; prevc, c: Constellation);
    BEGIN
        IF prevc = NIL THEN G.cons := c.next ELSE prevc.next := c.next END ;
        IF del.cons = NIL THEN del.cons := c ELSE del.lastcons.next := c END ;
        del.lastcons := c;
        IF G.lastcons = c THEN G.lastcons:= prevc END ;
        Release(c); c.Draw(update)
    END CutCons;
    PROCEDURE CutStar (G:Graph; prevs, s: Star);
    BEGIN
        IF prevs = NIL THEN G.stars := s.next ELSE prevs.next := s.next END ;
        IF del.stars = NIL THEN del.stars := s ELSE del.laststar.next := s END ;
        del.laststar := s;
        IF G.laststar = s THEN G.laststar := prevs END ;
        IF s IS Planet THEN Release(s(Planet).c) END ;
        s.ref := 0;
        s.Draw(update)
    END CutStar;
    PROCEDURE DelStar(G: Graph; o: Object);
        VAR s, prevs: Star;
    BEGIN
        s := G.stars; prevs := NIL;
        WHILE (s # NIL) & (s # o) DO prevs := s; s := s.next END ;
        IF s # NIL THEN CutStar(G, prevs, s) END
    END DelStar;
    PROCEDURE (G: Graph) Delete* (o: Object);
        VAR c, prevc: Constellation; i: INTEGER;
    BEGIN
        KeplerPorts.InitBalloon(update);
        delG := G; del.cons := NIL; del.stars := NIL;
        IF o IS Constellation THEN
            c := G.cons; prevc := NIL;
            WHILE (c # NIL) & (c # o) DO prevc := c; c := c.next END ;
            IF c # NIL THEN
                CutCons(G, prevc, c); i := 0;
                WHILE i < c.nofpts DO
                    IF (c.p[i].refcnt = 0) & ~(c.p[i] IS Planet) THEN DelStar(G, c.p[i]) END ;
                    INC(i)
                END
            END
        ELSE ASSERT(o(Star).refcnt = 0);
            IF o IS Planet THEN
                c := o(Planet).c; Release(c); i := 0;
                WHILE i < c.nofpts DO
                    IF (c.p[i].refcnt = 0) & ~(c.p[i] IS Planet) THEN DelStar(G, c.p[i]) END ;
                    INC(i)
                END
            END ;
            DelStar(G, o)
        END ;
        IF del.cons # NIL THEN del.lastcons.next := NIL END ;
        IF del.stars # NIL THEN del.laststar.next := NIL END ;
        G.notify(restore, G, NIL, update)
    END Delete;
    PROCEDURE (G: Graph) DeleteSelection* (minstate: INTEGER);
        VAR s, prevs: Star; c, prevc: Constellation;
    BEGIN
        delG := G; KeplerPorts.InitBalloon(update);
    (*move all constellations with (State >= minstate) into del buffer*)
        c := G.cons; prevc := NIL; del.cons := NIL;
        WHILE c # NIL DO
            IF c.State() >= minstate THEN CutCons(G, prevc, c) ELSE prevc := c END ;
            c := c.next
        END ;
        IF del.cons # NIL THEN del.lastcons.next := NIL END ;
    (*move all unused stars and planets with refcnt=0 & c.State>=minstate into del buffer*)
        ReverseStars(G);
        s := G.stars; prevs := NIL; del.stars := NIL;
        WHILE s # NIL DO
            IF (s.refcnt = 0) & (~(s IS Planet) OR s.sel OR (s(Planet).c.State() >= minstate)) THEN CutStar(G, prevs, s)
            ELSE prevs := s
            END ;
            s := s.next
        END ;
        ReverseStars(G) ;
        IF del.stars # NIL THEN del.laststar.next := NIL; ReverseStars(del) END ;
        G.notify(restore, G, NIL, update)
    END DeleteSelection;
    PROCEDURE (G: Graph) All* (op: INTEGER);    (* deselect = 0; select = 1 *)
        VAR p: Star;
    BEGIN p := G.stars;
        KeplerPorts.InitBalloon(update);
        WHILE p # NIL DO
            IF (op = 1) # p.sel THEN
                IF p.sel THEN p.Draw(update); p.sel := FALSE
                ELSE p.sel := TRUE; p.Draw(update); G.seltime := Oberon.Time()
                END
            END ;
            p := p.next
        END ;
        IF op = 0 THEN G.seltime := -1 END ;
        G.notify(restore, G, NIL, update)
    END All;
    PROCEDURE Store(G: Graph; VAR R: Files.Rider; all: BOOLEAN);
        VAR p, dummy: Star; c: Constellation;
    BEGIN
        p := G.stars;
        NEW(dummy);
        WHILE p # NIL DO
            IF all OR (p.sel & ~(p IS Planet)) THEN
                WriteObj(R, p); p.ref := nofpt; INC(nofpt)
            ELSIF p.sel & (p(Planet).c.State() = 2) THEN
                WriteObj(R, p); p.ref := nofpt; INC(nofpt)
            ELSIF p.sel & (p(Planet).c.State() # 2) THEN
                dummy^ := p^; WriteObj(R, dummy); p.ref := nofpt; INC(nofpt)
            END ;
            p := p.next
        END ;
        c := G.cons;
        WHILE c # NIL DO
            IF all OR (c.State()=2) THEN WriteObj(R, c) END ;
            c := c.next
        END ;
        Files.WriteNum(R, -1)
    END Store;
    PROCEDURE (G: Graph) Draw* (P: KeplerPorts.Port);
        VAR s: Star; c: Constellation;
    BEGIN
        c := G.cons;
        WHILE c # NIL DO c.Draw(P); c := c.next END ;
        s := G.stars;
        WHILE s # NIL DO s.Draw(P); s := s.next END
    END Draw;
    PROCEDURE (G: Graph) Write* (VAR R: Files.Rider);
    BEGIN
        Store(G, R, TRUE)
    END Write;
    PROCEDURE (G: Graph) WriteSel* (VAR R: Files.Rider);
    BEGIN Store(G, R, FALSE)
    END WriteSel;
    PROCEDURE DoubleStarTab;
        VAR h: StarTab; i: LONGINT;
    BEGIN i := 0; NEW(h, LEN(starTab^)*2);
        WHILE i < LEN(starTab^) DO h[i] := starTab[i]; INC(i) END ;
        starTab := h
    END DoubleStarTab;
    PROCEDURE (G: Graph) Read* (VAR R: Files.Rider);
        VAR o, o0: Object;
    BEGIN loading := G;
        G.stars := NIL; G.laststar := NIL; G.cons := NIL; G.lastcons := NIL; G.seltime := -1;
        ReadObj(R, o0); o := o0;
        WHILE o # NIL DO    (* append without notification *)
            WITH o: Star DO
                IF G.stars = NIL THEN G.stars := o ELSE G.laststar.next := o END ;
                G.laststar := o; o.next := NIL;
                IF nofpt = LEN(starTab^) THEN DoubleStarTab END ;
                starTab[nofpt] := SYSTEM.VAL(LONGINT, o); INC(nofpt)
            | o: Constellation DO
                IF G.cons = NIL THEN G.cons := o ELSE G.lastcons.next := o END ;
                G.lastcons := o; o.next := NIL
            END ;
            ReadObj(R, o)
        END
    END Read;
    PROCEDURE Old*(name: ARRAY OF CHAR): Graph;
        VAR F: Files.File; R: Files.Rider; o: Object;
    BEGIN F := Files.Old(name);
        IF F # NIL THEN Files.Set(R, F, 0); Reset; ReadObj(R, o);
            IF R.res = 0 THEN RETURN o(Graph) ELSE RETURN NIL END
        ELSE RETURN NIL
        END
    END Old;
    PROCEDURE *Dummy(op: INTEGER; g: Graph; c: Object; f: KeplerPorts.Port);
    END Dummy;
    PROCEDURE (G: Graph) CopySelection* (from: Graph; dx, dy: INTEGER);
        VAR cpBuf: Files.File;
            R: Files.Rider;
            c, nextc: Constellation;
            p, nextp: Star;
            buf: Graph;
    BEGIN
        cpBuf := Files.New("");
        Files.Set(R, cpBuf, 0);
        Reset; from.WriteSel(R);
        Files.Set(R, cpBuf, 0); Types.NewObj(buf, Types.TypeOf(from)); buf.notify := Dummy;
        Reset; buf.Read(R);
        p := buf.stars;
        WHILE p # NIL DO nextp := p.next;
            INC(p.x, dx); INC(p.y, dy);
            IF (p.refcnt > 0) OR (p IS Planet) THEN G.Append(p) END;
            p := nextp
        END ;
        c := buf.cons; KeplerPorts.InitBalloon(update);
        WHILE c # NIL DO c.Draw(update); nextc := c.next;
            IF G.cons = NIL THEN G.cons := c ELSE G.lastcons.next := c END ;
            G.lastcons := c; c.next := NIL;
            c := nextc
        END ;
        G.notify(restore, G, NIL, update)
    END CopySelection;
    PROCEDURE (G: Graph) SendToBack* (o: Object);
        VAR i: INTEGER;
            s: Star;
            c: Constellation;
    BEGIN
        WITH
            o: Star DO
                s := G.stars;
                IF o # s THEN
                    WHILE s.next # o DO s := s.next END ;
                    s.next := o.next; o.next := G.stars; G.stars := o;
                    IF G.laststar = o THEN G.laststar := s END ;
                    IF o IS Planet THEN    (* preserve topological order *)
                        c := o(Planet).c;
                        FOR i := 0 TO c.nofpts-1 DO
                            G.SendToBack(c.p[i])
                        END
                    END
                END
        | o: Constellation DO
                KeplerPorts.InitBalloon(update);
                c := G.cons;
                IF o # c THEN
                    WHILE c.next # o DO c := c.next END ;
                    c.next := o.next; o.next := G.cons; G.cons := o;
                    IF G.lastcons = o THEN G.lastcons := c END ;
                    o.Draw(update);
                    G.notify(restore, G, NIL, update)
                END
        END
    END SendToBack;
    PROCEDURE Unrelease(c: Constellation);
        VAR i: INTEGER;
    BEGIN i := 0;
        WHILE i < c.nofpts DO INC(c.p[i].refcnt); INC(i) END
    END Unrelease;
    PROCEDURE Recall*;
        VAR s, nexts: Star; c, nextc: Constellation;
    BEGIN
        IF delG # NIL THEN
            s := del.stars;
            WHILE s # NIL DO
                nexts := s.next; s.sel := FALSE; delG.Append(s);
                IF s IS Planet THEN Unrelease(s(Planet).c) END ;
                s := nexts
            END ;
            c := del.cons;
            WHILE c # NIL DO nextc := c.next; delG.Append(c); Unrelease(c); c := nextc END ;
            delG := NIL; del.cons := NIL; del.lastcons := NIL; del.stars := NIL; del.laststar := NIL
        END
    END Recall;
BEGIN NEW(update); NEW(del); NEW(starTab, 1)
END KeplerGraphs.